--------------------------------------------------------------------------------
-- |
-- Module      :  Lambola.IDL.Parser
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Happy Parser
--
--------------------------------------------------------------------------------

{


module Lambola.IDL.Parser
  (

    parseIDL
  , parse

  ) where

import Lambola.IDL.Lexer
import Lambola.IDL.ParseMonad
import Lambola.IDL.Syntax
import Lambola.IDL.Token

import Control.Monad.Identity

}



%name idlParser specification

%lexer { idlLex } { L _ TK_EOF }
%monad { ParseM } { >>= } { return }
%error { parseError }


%tokentype { Lexeme }

%token
  ANY                 { L _ TK_KW_any               }
  ATTRIBUTE           { L _ TK_KW_attribute         }
  BOOLEAN             { L _ TK_KW_boolean           }
  CASE                { L _ TK_KW_case              }
  CHAR                { L _ TK_KW_char              }
  CONST               { L _ TK_KW_const             }
  CONTEXT             { L _ TK_KW_context           }
  DEFAULT             { L _ TK_KW_default           }
  DOUBLE              { L _ TK_KW_double            }
  ENUM                { L _ TK_KW_enum              }
  EXCEPTION           { L _ TK_KW_exception         }
  FALSE               { L _ TK_KW_FALSE             }
  FLOAT               { L _ TK_KW_float             }
  IN                  { L _ TK_KW_in                }
  INOUT               { L _ TK_KW_inout             }
  INTERFACE           { L _ TK_KW_interface         }
  LOCAL               { L _ TK_KW_local             }
  LONG                { L _ TK_KW_long              }
  MODULE              { L _ TK_KW_module            }
  NATIVE              { L _ TK_KW_native            }
  OBJECT              { L _ TK_KW_Object            }
  OCTET               { L _ TK_KW_octet             }
  ONEWAY              { L _ TK_KW_oneway            }
  OUT                 { L _ TK_KW_out               }
  RAISES              { L _ TK_KW_raises            }
  READONLY            { L _ TK_KW_readonly          }
  SEQUENCE            { L _ TK_KW_sequence          }
  SHORT               { L _ TK_KW_short             }
  STRING              { L _ TK_KW_string            }
  STRUCT              { L _ TK_KW_struct            }
  SWITCH              { L _ TK_KW_switch            }
  TRUE                { L _ TK_KW_TRUE              }
  TYPEDEF             { L _ TK_KW_typedef           }
  UNSIGNED            { L _ TK_KW_unsigned          }
  UNION               { L _ TK_KW_union             }
  VOID                { L _ TK_KW_void              }

  IDENTIFIER          { L _ (TK_identifier $$)      }

  INTEGER_LITERAL     { L _ (TK_LIT_integer $$)     }
  STRING_LITERAL      { L _ (TK_LIT_string $$)      }
  CHARACTER_LITERAL   { L _ (TK_LIT_character $$)   }
  FLOATING_PT_LITERAL { L _ (TK_LIT_floating_pt $$) }

  OR_OP               { L _ TK_OP_bar               }
  XOR_OP              { L _ TK_OP_caret             }
  AND_OP              { L _ TK_OP_ampersand         }
  SHIFTL              { L _ TK_OP_shiftl            }
  SHIFTR              { L _ TK_OP_shiftr            }
  PLUS                { L _ TK_OP_plus              }
  MINUS               { L _ TK_OP_minus             }
  MULTIPLY            { L _ TK_OP_mult              }
  DIVIDE              { L _ TK_OP_divide            }
  MODULO              { L _ TK_OP_modulo            }
  TILDE               { L _ TK_OP_tilde             }

  SEMICOLON           { L _ TK_P_semicolon          }
  LEFT_BRACE          { L _ TK_P_lbrace             }
  RIGHT_BRACE         { L _ TK_P_rbrace             }
  DOUBLE_COLON        { L _ TK_P_double_colon       }
  COLON               { L _ TK_P_colon              }
  COMMA               { L _ TK_P_comma              }
  EQUAL               { L _ TK_P_equal              }
  LEFT_PAREN          { L _ TK_P_lparen             }
  RIGHT_PAREN         { L _ TK_P_rparen             }
  LEFT_ANGLE          { L _ TK_P_langle             }
  RIGHT_ANGLE         { L _ TK_P_rangle             }
  LEFT_SQUARE         { L _ TK_P_lsquare            }
  RIGHT_SQUARE        { L _ TK_P_rsquare            }







%%

-- (1) specification
specification :: { [Definition] }
  : definition_list1                    { toListH $1 }

definition_list1 ::  { (H Definition) }
  : definition                          { wrapH $1 }
  | definition_list1 definition         { $1 `snocH` $2 }

definition_list ::  { (H Definition) }
  : {- empty -}                         { emptyH }
  | definition_list definition          { $1 `snocH` $2 }


-- (2) definition
definition :: { Definition }
  : type_dcl SEMICOLON                  { $1 }
  | const_dcl SEMICOLON                 { $1 }
  | except_dcl SEMICOLON                { $1 }
  | interface SEMICOLON                 { $1 }
  | idlmodule SEMICOLON                 { $1 }

-- (3) module (called idlmodule)
idlmodule :: { Definition }
  : MODULE IDENTIFIER LEFT_BRACE definition_list RIGHT_BRACE
                                        { Module $2 (toListH $4) }


-- (4) interface
interface :: { Definition }
  : interface_dcl                       { $1 }
  | forward_dcl                         { $1 }


-- (5) interface_dcl
interface_dcl :: { Definition }
  : interface_header LEFT_BRACE interface_body RIGHT_BRACE
                                        { let (ident,xs) = $1 in InterfaceDcl ident xs $3 }


-- (6) forward_dcl
forward_dcl :: { Definition }
  : INTERFACE IDENTIFIER                { ForwardDcl $2 }


-- (7) interface_header
interface_header :: { (Identifier,[ScopedName]) }
  : INTERFACE IDENTIFIER {- empty -}    { ($2,[]) }
  | INTERFACE IDENTIFIER inheritance_spec
                                        { ($2,$3) }


-- (8) interface_body
interface_body :: { [Definition] }
  : export_list                         { toListH $1 }


-- (9) export
export :: { Definition }
  : type_dcl SEMICOLON                  { $1 }
  | const_dcl SEMICOLON                 { $1 }
  | except_dcl SEMICOLON                { $1 }
  | attr_dcl SEMICOLON                  { $1 }
  | op_dcl SEMICOLON                    { $1 }


export_list :: { (H Definition) }
  : {- empty -}                         { emptyH }
  | export_list export                  { $1 `snocH` $2 }


-- (10) inheritance_spec
inheritance_spec :: { [ScopedName] }
  : COLON scoped_name_list1_c            { toListH $2 }


-- (11) scoped_name
scoped_name :: { ScopedName }
  : scoped_name_rec                      { makeScopedName $ toListH $1 }


scoped_name_rec :: { (H Identifier) }
  : IDENTIFIER                          { wrapH $1 }
  | DOUBLE_COLON IDENTIFIER             { wrapH $2 }
  | scoped_name_rec DOUBLE_COLON IDENTIFIER
                                        { $1 `snocH` $3 }



scoped_name_list1_c :: { (H ScopedName) }
  : scoped_name                         { wrapH $1 }
  | scoped_name_list1_c COMMA scoped_name
                                        { $1 `snocH` $3 }


-- (12) const_dcl
const_dcl :: { Definition }
  : CONST const_type IDENTIFIER EQUAL const_exp
                                        { ConstDcl $2 $3 $5 }


-- (13) const_type
const_type :: { TypeSpec }
  : integer_type                        { $1 }
  | char_type                           { $1 }
  | boolean_type                        { $1 }
  | floating_pt_type                    { $1 }
  | string_type                         { $1 }
  | scoped_name                         { TyNamed $1 }


-- (14) const_exp
const_exp :: { ConstExp }
  : or_expr                             { $1 }


-- (15) or_expr
or_expr :: { ConstExp }
  : xor_expr                            { $1 }
  | or_expr OR_OP xor_expr              { BinaryExp BIN_OR $1 $3 }


-- (16) xor_expr
xor_expr :: { ConstExp }
  : and_expr                            { $1 }
  | xor_expr XOR_OP and_expr            { BinaryExp BIN_XOR $1 $3 }


-- (17) and_expr
and_expr :: { ConstExp }
  : shift_expr                          { $1 }
  | and_expr AND_OP shift_expr          { BinaryExp BIN_AND $1 $3 }


-- (18) shift_expr
shift_expr :: { ConstExp }
  : add_expr                            { $1 }
  | shift_expr SHIFTR add_expr          { BinaryExp BIN_SHIFTR $1 $3 }
  | shift_expr SHIFTL add_expr          { BinaryExp BIN_SHIFTL $1 $3 }


-- (19) add_expr
add_expr :: { ConstExp }
  : mult_expr                           { $1 }
  | add_expr PLUS mult_expr             { BinaryExp BIN_PLUS $1 $3 }
  | add_expr MINUS mult_expr            { BinaryExp BIN_MINUS $1 $3 }


-- (20) mult_expr
mult_expr :: { ConstExp }
  : unary_expr                          { $1 }
  | mult_expr MULTIPLY unary_expr       { BinaryExp BIN_MULT $1 $3 }
  | mult_expr DIVIDE unary_expr         { BinaryExp BIN_DIV $1 $3 }
  | mult_expr MODULO unary_expr         { BinaryExp BIN_MOD $1 $3 }


-- (21) unary_expr
unary_expr :: { ConstExp }
  : unary_operator primary_expr         { UnaryExp $1 $2 }
  | primary_expr                        { $1 }


-- (22) unary_operator
unary_operator :: { UnaryOp }
  : MINUS                               { UNARY_NEGATE }
  | PLUS                                { UNARY_PLUS }
  | TILDE                               { UNARY_BNOT }


-- (23) primary_expr
primary_expr :: { ConstExp }
  : scoped_name                         { NamedExp $1 }
  | literal                             { $1 }
  | LEFT_PAREN const_exp RIGHT_PAREN    { $2 }


-- (24) literal
literal :: { ConstExp }
  : INTEGER_LITERAL                     { IntegerLit $1 }
  | STRING_LITERAL                      { StringLit $1 }
  | CHARACTER_LITERAL                   { CharLit $1 }
  | FLOATING_PT_LITERAL                 { FloatingPtLit $1 }
  | boolean_literal                     { $1 }


-- (25) boolean_literal
boolean_literal :: { ConstExp }
  : TRUE                                { BooleanLit True }
  | FALSE                               { BooleanLit False }


-- (26) positive_int_const
positive_int_const :: { ConstExp }
  : const_exp                           { $1 }


-- (27) type_dcl
type_dcl :: { Definition }
  : TYPEDEF type_declarator             { let (a,b) = $2 in TypedefDcl a b }
  | struct_type                         { TypeDcl $1 }
  | union_type                          { TypeDcl $1 }
  | enum_type                           { TypeDcl $1 }


-- (28) type_declarator
type_declarator :: { (TypeSpec,[Declarator]) }
  : type_spec declarators               { ($1, $2) }


-- (29) type_spec
type_spec :: { TypeSpec }
  : simple_type_spec                    { $1 }
  | constr_type_spec                    { $1 }


-- (30) simple_type_spec
simple_type_spec :: { TypeSpec }
  : base_type_spec                      { $1 }
  | template_type_spec                  { $1 }
  | scoped_name                         { TyNamed $1 }


-- (31) base_type_spec
base_type_spec :: { TypeSpec}
  : floating_pt_type                    { $1 }
  | integer_type                        { $1 }
  | char_type                           { $1 }
  | boolean_type                        { $1 }
  | octet_type                          { $1 }
  | any_type                            { $1 }

-- (32) template_type_spec
template_type_spec :: { TypeSpec }
  : sequence_type                       { $1 }
  | string_type                         { $1 }


-- (33) constr_type_spec
constr_type_spec :: { TypeSpec }
  : struct_type                         { $1 }
  | union_type                          { $1 }
  | enum_type                           { $1 }


-- (34) declarators
declarators :: { [Declarator] }
  : declarator_list1_c                  { toListH $1 }


-- (35) declarator
declarator :: { Declarator }
  : simple_declarator                   { $1 }
  | complex_declarator                  { $1 }

declarator_list1_c :: { (H Declarator) }
  : declarator                          { wrapH $1 }
  | declarator_list1_c COMMA declarator { $1 `snocH` $3 }


-- (36) simple_declarator
simple_declarator :: { Declarator }
  : IDENTIFIER                          { SimpleDeclarator $1 }


-- (37) complex_declarator
complex_declarator :: { Declarator }
  : array_declarator                    { $1 }


-- (38) floating_pt_type
floating_pt_type :: { TypeSpec }
  : FLOAT                               { TyFloat FLOAT }
  | DOUBLE                              { TyFloat DOUBLE }


-- (39) integer_type
integer_type :: { TypeSpec }
  : signed_int                          { $1 }
  | unsigned_int                        { $1 }


-- (40) signed_int
signed_int :: { TypeSpec }
  : signed_long_int                     { $1 }
  | signed_short_int                    { $1 }


-- (41) signed_long_int
signed_long_int :: { TypeSpec }
  : LONG                                { TyInt SIGNED_LONG_INT }


-- (42) signed_short_int
signed_short_int :: { TypeSpec }
  : SHORT                               { TyInt SIGNED_SHORT_INT }


-- (43) unsigned_int
unsigned_int :: { TypeSpec }
  : unsigned_long_int                   { $1 }
  | unsigned_short_int                  { $1 }


-- (44) unsigned_long_int
unsigned_long_int :: { TypeSpec }
  : UNSIGNED LONG                       { TyInt UNSIGNED_LONG_INT }


-- (45) unsigned_short_int
unsigned_short_int :: { TypeSpec }
  : UNSIGNED SHORT                      { TyInt UNSIGNED_SHORT_INT }


-- (46) char_type
char_type :: { TypeSpec }
  : CHAR                                { TyChar }


-- (47) boolean_type
boolean_type :: { TypeSpec }
  : BOOLEAN                             { TyBoolean }


-- (48) octet_type
octet_type :: { TypeSpec }
  : OCTET                               { TyOctet }


-- (49) any_type
any_type :: { TypeSpec }
  : ANY                                 { TyAny }


-- (50) struct_type
--
-- Note the grammar includes a comment stating that
-- /structure types may also be names using a typedef declaration/.
--
-- Such structs need a post-processing phase eliminating the dummy
-- identifier @%unresolved@.
--

struct_type :: { TypeSpec }
  : STRUCT IDENTIFIER LEFT_BRACE member_list RIGHT_BRACE
                                        { TyStruct $2 $4 }
  | STRUCT LEFT_BRACE member_list RIGHT_BRACE
                                        { TyStruct "%unresolved" $3 }


-- (51) member_list
member_list :: { [Member] }
  : member_list1                        { toListH $1 }


member_list1 :: { (H Member) }
  : member                              { wrapH $1 }
  | member_list1 member                 { $1 `snocH` $2 }


-- (52) member
member :: { Member }
  : type_spec declarators SEMICOLON { Member $1 $2 }


-- (53) union_type
union_type :: { TypeSpec }
  : UNION IDENTIFIER SWITCH LEFT_PAREN switch_type_spec RIGHT_PAREN
    LEFT_BRACE switch_body RIGHT_BRACE
                                        { TyUnion $2 $5 $8 }


-- (54) switch_type_spec
switch_type_spec :: { TypeSpec }
  : integer_type                        { $1 }
  | char_type                           { $1 }
  | boolean_type                        { $1 }
  | enum_type                           { $1 }
  | scoped_name                         { TyNamed $1 }


-- (55) switch_body
switch_body :: { [UnionCase] }
  : union_case_list1                    { toListH $1 }


union_case_list1 :: { (H UnionCase) }
  : union_case                          { wrapH $1 }
  | union_case_list1 union_case         { $1 `snocH` $2 }

-- (56) [union] case
union_case :: { UnionCase }
  : case_label_list1 element_spec SEMICOLON
                                        { UnionCase (toListH $1) $2 }

case_label_list1 :: { (H CaseLabel) }
  : case_label                          { wrapH $1 }
  | case_label_list1 case_label         { $1 `snocH` $2 }


-- (57) case_label
case_label :: { CaseLabel }
  : CASE const_exp COLON                { CaseOf $2 }
  | DEFAULT COLON                       { CaseDefault }



-- (58) element_spec
element_spec :: { ElementSpec }
  : type_spec declarator                { ElementSpec $1 $2 }


-- (59) enum_type
enum_type :: { TypeSpec }
  : ENUM IDENTIFIER LEFT_BRACE enumerator_list1_c RIGHT_BRACE
                                        { TyEnum $2 (toListH $4) }


enumerator_list1_c :: { (H Identifier) }
  : enumerator                          { wrapH $1 }
  | enumerator_list1_c COMMA enumerator { $1 `snocH` $3 }


-- (60) enumerator
enumerator :: { Identifier }
  : IDENTIFIER                          { $1 }


-- (61) sequence_type
sequence_type :: { TypeSpec }
  : SEQUENCE LEFT_ANGLE simple_type_spec COMMA positive_int_const RIGHT_ANGLE
                                        { TySequence $3 (Just $5) }
  | SEQUENCE LEFT_ANGLE simple_type_spec RIGHT_ANGLE
                                        { TySequence $3 Nothing }


-- (62) string_type
string_type :: { TypeSpec }
  : STRING LEFT_ANGLE positive_int_const RIGHT_ANGLE
                                        { TyString (Just $3) }
  | STRING                              { TyString Nothing }


-- (63) array_declarator
array_declarator :: { Declarator }
  : IDENTIFIER fixed_array_size_list1   { ArrayDeclarator $1 (toListH $2) }


fixed_array_size_list1 :: { (H ConstExp) }
  : fixed_array_size                    { wrapH $1 }
  | fixed_array_size_list1 fixed_array_size
                                        { $1 `snocH` $2 }

-- (64) fixed_array_size
fixed_array_size :: { ConstExp }
  : LEFT_SQUARE positive_int_const RIGHT_SQUARE
                                        { $2 }


-- (65) attr_dcl
attr_dcl :: { Definition }
  : read_only ATTRIBUTE param_type_spec simple_declarator_list1
                                        { AttrDcl $1 $3 (toListH $4) }


simple_declarator_list1 :: { (H Declarator) }
  : simple_declarator                   { wrapH $1 }
  | simple_declarator_list1 simple_declarator
                                        { $1 `snocH` $2 }


read_only :: { AccessSpec }
  : {- empty -}                         { ACCESS_RW }
  | READONLY                            { READONLY }

-- (66) except_dcl
except_dcl :: { Definition }
  : EXCEPTION IDENTIFIER LEFT_BRACE member_list RIGHT_BRACE
                                        { ExceptDcl $2 $4 }


-- (67) op_dcl
op_dcl :: { Definition }
  : op_attribute op_type_spec IDENTIFIER parameter_dcls
    raises_expr_maybe context_expr_maybe
                                        { OpDcl $1 $2 $3 $4 $5 $6 }


-- (68) op_attribute
op_attribute :: { OpAttribute }
  : {- empty -}                         { NO_ATTR }
  | ONEWAY                              { ONEWAY }

op_attibute_maybe :: { (Maybe OpAttribute) }
  : {- empty -}                         { Nothing }
  | op_attribute                        { Just $1 }


-- (69) op_type_spec
op_type_spec :: { TypeSpec }
  : param_type_spec                     { $1 }
  | VOID                                { TyVoid }


-- (70) parameter_dcls
parameter_dcls :: { [ParamDcl] }
  : LEFT_PAREN param_dcl_list1_c RIGHT_PAREN
                                        { toListH $2 }
  | LEFT_PAREN RIGHT_PAREN              { [] }


param_dcl_list1_c :: { (H ParamDcl) }
  : param_dcl                           { wrapH $1 }
  | param_dcl_list1_c COMMA param_dcl   { $1 `snocH` $3 }


-- (71) param_dcl
param_dcl :: { ParamDcl }
  : param_attribute param_type_spec simple_declarator
                                        { ParamDcl $1 $2 $3 }


-- (72) param_attribute
param_attribute :: { ParamAttribute }
  : IN                                  { IN }
  | OUT                                 { OUT }
  | INOUT                               { INOUT }


-- (73) raises_expr
raises_expr :: { RaisesExpr }
  : RAISES LEFT_PAREN scoped_name_list1_c RIGHT_PAREN
                                        { toListH $3 }


raises_expr_maybe :: { (Maybe RaisesExpr) }
  : {- empty -}                         { Nothing }
  | raises_expr                         { Just $1 }


-- (74) context_expr
context_expr :: { ContextExpr }
  : CONTEXT LEFT_PAREN string_literal_list1_c RIGHT_PAREN
                                        { toListH $3 }


string_literal_list1_c :: { (H String) }
  : STRING_LITERAL                      { wrapH $1 }
  | string_literal_list1_c COMMA STRING_LITERAL
                                        { $1 `snocH` $3 }


context_expr_maybe :: { (Maybe ContextExpr) }
  : {- empty -}                         { Nothing }
  | context_expr                        { Just $1 }


-- (75) param_type_spec
param_type_spec :: { TypeSpec }
  : base_type_spec                      { $1 }
  | string_type                         { $1 }
  | scoped_name                         { TyNamed $1 }



-------------- OLD GLSL code -----

{


-- Hughes List

type H a = [a] -> [a]

wrapH :: a -> H a
wrapH = (:)

snocH :: H a -> a -> H a
snocH f a = f . (a:)

emptyH :: H a
emptyH = id

toListH :: H a -> [a]
toListH f = f $ []


parseIDL :: FilePath -> String -> Either String [Definition]
parseIDL path contents  =
  case runIdentity (runParseT idlParser path contents) of
    Left (ParseErr err) -> Left err
    Right ans           -> Right ans


parse :: FilePath -> IO (Either String [Definition])
parse path = readFile path >>= \contents -> return $ parseIDL path contents




makeScopedName :: [Identifier] -> ScopedName
makeScopedName = fn []
  where
    fn _   []     = error "makeScopedName - should be a parse fail not an error..."
    fn acc [x]    = ScopedName acc x
    fn acc (x:xs) = fn (acc++[x]) xs


}
